home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 2003 August / MW 8 2003 CD1.iso / Inside Macworld / Product News / gimp-1.2.4.sit / gimp-1.2.4 / plug-ins / perl / Net / Net.pm < prev    next >
Encoding:
Perl POD Document  |  2003-01-14  |  10.7 KB  |  395 lines
  1. #
  2. # This package is loaded by the Gimp, and is !private!, so don't
  3. # use it standalone, it won't work.
  4. #
  5. package Gimp::Net;
  6.  
  7. use strict 'vars';
  8. use vars qw(
  9.    $VERSION
  10.    $default_tcp_port $default_unix_dir $default_unix_sock
  11.    $server_fh $trace_level $trace_res $auth $gimp_pid
  12. );
  13. use subs qw(gimp_call_procedure);
  14. use base qw(DynaLoader);
  15.  
  16. use Socket; # IO::Socket is _really_ slow, so don't use it!
  17.  
  18. use Gimp ('croak','__');
  19. use Fcntl qw(F_SETFD);
  20.  
  21. require DynaLoader;
  22.  
  23. $VERSION = 1.211;
  24.  
  25. bootstrap Gimp::Net $VERSION;
  26.  
  27. $default_tcp_port  = 10009;
  28. $default_unix_dir  = "/tmp/gimp-perl-serv-uid-$>/";
  29. $default_unix_sock = "gimp-perl-serv";
  30.  
  31. $trace_res = *STDERR;
  32. $trace_level = 0;
  33.  
  34. my $initialized = 0;
  35.  
  36. sub initialized { $initialized }
  37.  
  38. sub import {
  39.    my $pkg = shift;
  40.  
  41.    return if @_;
  42.  
  43.    # overwrite some destroy functions
  44.    *Gimp::Tile::DESTROY=
  45.    *Gimp::PixelRgn::DESTROY=
  46.    *Gimp::GDrawable::DESTROY=sub {
  47.       my $req="DTRY".args2net(0,@_);
  48.       print $server_fh pack("N",length($req)).$req;
  49.  
  50.       # make this synchronous to avoid deadlock due to using non sys*-type functions
  51.       my $len;
  52.       read($server_fh,$len,4) == 4 or die "protocol error (11)";
  53.    };
  54. }
  55.  
  56. sub _gimp_procedure_available {
  57.    my $req="TEST".$_[0];
  58.    print $server_fh pack("N",length($req)).$req;
  59.    read($server_fh,$req,1);
  60.    return $req;
  61. }
  62.  
  63. # this is hardcoded into gimp_call_procedure!
  64. sub response {
  65.    my($len,$req);
  66.    read($server_fh,$len,4) == 4 or die "protocol error (1)";
  67.    $len=unpack("N",$len);
  68.    read($server_fh,$req,$len) == $len or die "protocol error (2)";
  69.    net2args(0,$req);
  70. }
  71.  
  72. # this is hardcoded into gimp_call_procedure!
  73. sub command {
  74.    my $req=shift;
  75.    $req.=args2net(0,@_);
  76.    print $server_fh pack("N",length($req)).$req;
  77. }
  78.  
  79. my($len,@args,$trace,$req); # small speedup, these are really local to gimp_call_procedure
  80.  
  81. sub gimp_call_procedure {
  82.    if ($trace_level) {
  83.       $req="TRCE".args2net(0,$trace_level,@_);
  84.       print $server_fh pack("N",length($req)).$req;
  85.       do {
  86.          read($server_fh,$len,4) == 4 or die "protocol error (3)";
  87.          $len=unpack("N",$len);
  88.          read($server_fh,$req,abs($len)) == $len or die "protocol error (4)";
  89.          if ($len<0) {
  90.             ($req,@args)=net2args(0,$req);
  91.             print "ignoring callback $req\n";
  92.             redo;
  93.          }
  94.          ($trace,$req,@args)=net2args(0,$req);
  95.          if (ref $trace_res eq "SCALAR") {
  96.             $$trace_res = $trace;
  97.          } else {
  98.             print $trace_res $trace;
  99.          }
  100.       } while 0;
  101.    } else {
  102.       $req="EXEC".args2net(0,@_);
  103.       print $server_fh pack("N",length($req)).$req;
  104.       do {
  105.          read($server_fh,$len,4) == 4 or die "protocol error (5)";
  106.          $len=unpack("N",$len);
  107.          read($server_fh,$req,abs($len)) == $len or die "protocol error (6)";
  108.          if ($len<0) {
  109.             ($req,@args)=net2args(0,$req);
  110.             print "ignoring callback $req\n";
  111.             redo;
  112.          }
  113.          ($req,@args)=net2args(0,$req);
  114.       } while 0;
  115.    }
  116.    croak $req if $req;
  117.    wantarray ? @args : $args[0];
  118. }
  119.  
  120. sub server_quit {
  121.    print $server_fh pack("N",4)."QUIT";
  122.    undef $server_fh;
  123. }
  124.  
  125. sub lock {
  126.    print $server_fh pack("N",12)."LOCK".pack("N*",1,0);
  127. }
  128.  
  129. sub unlock {
  130.    print $server_fh pack("N",12)."LOCK".pack("N*",0,0);
  131. }
  132.  
  133. sub set_trace {
  134.    my($trace)=@_;
  135.    my $old_level = $trace_level;
  136.    if(ref $trace) {
  137.       $trace_res=$trace;
  138.    } elsif (defined $trace) {
  139.       $trace_level=$trace;
  140.    }
  141.    $old_level;
  142. }
  143.  
  144. sub start_server {
  145.    my $opt = shift;
  146.    $opt = $Gimp::spawn_opts unless $opt;
  147.    print __"trying to start gimp with options \"$opt\"\n" if $Gimp::verbose;
  148.    $server_fh=local *SERVER_FH;
  149.    my $gimp_fh=local *CLIENT_FH;
  150.    socketpair $server_fh,$gimp_fh,AF_UNIX,SOCK_STREAM,PF_UNSPEC
  151.       or socketpair $server_fh,$gimp_fh,AF_LOCAL,SOCK_STREAM,PF_UNSPEC
  152.       or croak __"unable to create socketpair for gimp communications: $!";
  153.  
  154.    # do it here so it i done only once
  155.    require Gimp::Config;
  156.    $gimp_pid = fork;
  157.    if ($gimp_pid > 0) {
  158.       Gimp::ignore_functions(@Gimp::gimp_gui_functions) unless $opt=~s/(^|:)gui//;
  159.       return $server_fh;
  160.    } elsif ($gimp_pid == 0) {
  161.       close $server_fh;
  162.       fcntl $gimp_fh, F_SETFD, 0;
  163.       delete $ENV{GIMP_HOST};
  164.       unless ($Gimp::verbose) {
  165.          open STDIN,"</dev/null";
  166.          open STDOUT,">/dev/null";
  167.          open STDERR,">&1";
  168.       }
  169.       my @args;
  170.       my $args = &Gimp::RUN_NONINTERACTIVE." ".
  171.                  (&Gimp::_PS_FLAG_BATCH | &Gimp::_PS_FLAG_QUIET)." ".
  172.                  fileno($gimp_fh);
  173.       push(@args,"--no-data") if $opt=~s/(^|:)no-?data//;
  174.       push(@args,"-i") unless $opt=~s/(^|:)gui//;
  175.       push(@args,"--verbose") if $Gimp::verbose;
  176.       { # block to suppress warning with broken perls (e.g. 5.004)
  177.          exec $Gimp::Config{GIMP},
  178.               "--no-splash",
  179.               "--no-splash-image",
  180.               "--enable-stack-trace", "never",
  181.               "--console-messages",
  182.               @args,
  183.               "-b",
  184.               "(extension-perl-server $args)",
  185.               "(gimp-quit 0)";
  186.       }
  187.       exit(255);
  188.    } else {
  189.       croak __"unable to fork: $!";
  190.    }
  191. }
  192.  
  193. sub try_connect {
  194.    local $_=$_[0];
  195.    my $fh;
  196.    $auth = s/^(.*)\@// ? $1 : "";    # get authorization
  197.    if ($_ ne "") {
  198.       if (s{^spawn/}{}) {
  199.          return start_server($_);
  200.       } elsif (s{^unix/}{/}) {
  201.          my $server_fh=local *FH;
  202.          return ((socket($server_fh,AF_UNIX,SOCK_STREAM,PF_UNSPEC)
  203.                  || socket $server_fh,AF_LOCAL,SOCK_STREAM,PF_UNSPEC)
  204.                 && connect($server_fh,sockaddr_un $_)
  205.                 ? $server_fh : ());
  206.       } else {
  207.          s{^tcp/}{};
  208.          my($host,$port)=split /:/,$_;
  209.          $port=$default_tcp_port unless $port;
  210.          my $server_fh=local *FH;
  211.          return socket($server_fh,PF_INET,SOCK_STREAM,scalar getprotobyname('tcp') || 6)
  212.                 && connect($server_fh,sockaddr_in $port,inet_aton $host)
  213.                 ? $server_fh : ();
  214.       }
  215.    } else {
  216.       return $fh if $fh = try_connect ("$auth\@unix$default_unix_dir$default_unix_sock");
  217.       return $fh if $fh = try_connect ("$auth\@tcp/127.1:$default_tcp_port");
  218.       return $fh if $fh = try_connect ("$auth\@spawn/");
  219.    }
  220.    undef $auth;
  221. }
  222.  
  223. sub gimp_init {
  224.    $Gimp::in_top=1;
  225.    if (@_) {
  226.       $server_fh = try_connect ($_[0]);
  227.    } elsif (defined($Gimp::host)) {
  228.       $server_fh = try_connect ($Gimp::host);
  229.    } elsif (defined($ENV{GIMP_HOST})) {
  230.       $server_fh = try_connect ($ENV{GIMP_HOST});
  231.    } else {
  232.       $server_fh = try_connect ("");
  233.    }
  234.    defined $server_fh or croak __"could not connect to the gimp server (make sure Perl-Server is running)";
  235.    { my $fh = select $server_fh; $|=1; select $fh }
  236.    
  237.    my @r = response;
  238.    
  239.    die __"expected perl-server at other end of socket, got @r\n"
  240.       unless $r[0] eq "PERL-SERVER";
  241.    shift @r;
  242.    die __"expected protocol version $Gimp::_PROT_VERSION, but server uses $r[0]\n"
  243.       unless $r[0] eq $Gimp::_PROT_VERSION;
  244.    shift @r;
  245.    
  246.    for(@r) {
  247.       if($_ eq "AUTH") {
  248.          die __"server requests authorization, but no authorization available\n"
  249.             unless $auth;
  250.          my $req = "AUTH".$auth;
  251.          print $server_fh pack("N",length($req)).$req;
  252.          my @r = response;
  253.          die __"authorization failed: $r[1]\n" unless $r[0];
  254.          print __"authorization ok, but: $r[1]\n" if $Gimp::verbose and $r[1];
  255.       }
  256.    }
  257.  
  258.    $initialized = 1;
  259.    Gimp::_initialized_callback;
  260. }
  261.  
  262. sub gimp_end {
  263.    $initialized = 0;
  264.  
  265.    #close $server_fh if $server_fh;
  266.    undef $server_fh;
  267.    kill 'KILL',$gimp_pid if $gimp_pid;
  268.    undef $gimp_pid;
  269. }
  270.  
  271. sub gimp_main {
  272.    gimp_init;
  273.    no strict 'refs';
  274.    $Gimp::in_top=0;
  275.    eval { Gimp::callback("-net") };
  276.    if($@ && $@ ne "IGNORE THIS MESSAGE\n") {
  277.       Gimp::logger(message => substr($@,0,-1), fatal => 1, function => 'DIE');
  278.       gimp_end;
  279.       -1;
  280.    } else {
  281.       gimp_end;
  282.       0;
  283.    }
  284. }
  285.  
  286. sub get_connection() {
  287.    [$server_fh,$gimp_pid];
  288. }
  289.  
  290. sub set_connection($) {
  291.    ($server_fh,$gimp_pid)=@{+shift};
  292. }
  293.  
  294. END {
  295.    gimp_end;
  296. }
  297.  
  298. 1;
  299. __END__
  300.  
  301. =head1 NAME
  302.  
  303. Gimp::Net - Communication module for the gimp-perl server.
  304.  
  305. =head1 SYNOPSIS
  306.  
  307.   use Gimp;
  308.  
  309. =head1 DESCRIPTION
  310.  
  311. For Gimp::Net (and thus commandline and remote scripts) to work, you first have to
  312. install the "Perl-Server" extension somewhere where Gimp can find it (e.g in
  313. your .gimp/plug-ins/ directory). Usually this is done automatically while installing
  314. the Gimp extension. If you have a menu entry C<<Xtns>/Perl-Server>
  315. then it is probably installed.
  316.  
  317. The Perl-Server can either be started from the C<<Xtns>> menu in Gimp, or automatically
  318. when a perl script can't find a running Perl-Server.
  319.  
  320. When started from within The Gimp, the Perl-Server will create a unix
  321. domain socket to which local clients can connect. If an authorization
  322. password is given to the Perl-Server (by defining the environment variable
  323. C<GIMP_HOST> before starting The Gimp), it will also listen on a tcp port
  324. (default 10009). Since the password is transmitted in cleartext, using the
  325. Perl-Server over tcp effectively B<lowers the security of your network to
  326. the level of telnet>. Even worse: the current Gimp::Net-protocol can be
  327. used for denial of service attacks, i.e. crashing the Perl-Server. There
  328. also *might* be buffer-overflows (although I do care a lot for these).
  329.  
  330. =head1 ENVIRONMENT
  331.  
  332. The environment variable C<GIMP_HOST> specifies the default server to
  333. contact and/or the password to use. The syntax is
  334. [auth@][tcp/]hostname[:port] for tcp, [auth@]unix/local/socket/path for unix
  335. and spawn/ for a private gimp instance. Examples are:
  336.  
  337.  www.yahoo.com               # just kidding ;)
  338.  yahoo.com:11100             # non-standard port
  339.  tcp/yahoo.com               # make sure it uses tcp
  340.  authorize@tcp/yahoo.com:123 # full-fledged specification
  341.  
  342.  unix/tmp/unx                # use unix domain socket
  343.  password@unix/tmp/test      # additionally use a password
  344.  
  345.  authorize@                  # specify authorization only
  346.  
  347.  spawn/                      # use a private gimp instance
  348.  spawn/nodata                # pass --no-data switch
  349.  spawn/gui                   # don't pass -n switch
  350.  
  351. =head1 CALLBACKS
  352.  
  353. =over 4
  354.  
  355. =item net()
  356.  
  357. is called after we have succesfully connected to the server. Do your dirty
  358. work in this function, or see L<Gimp::Fu> for a better solution.
  359.  
  360. =back
  361.  
  362. =head1 FUNCTIONS
  363.  
  364. =over 4
  365.  
  366. =item server_quit()
  367.  
  368. sends the perl server a quit command.
  369.  
  370. =item get_connection()
  371.  
  372. return a connection id which uniquely identifies the current connection.
  373.  
  374. =item set_connection(conn_id)
  375.  
  376. set the connection to use on subsequent commands. C<conn_id> is the
  377. connection id as returned by get_connection().
  378.  
  379. =back
  380.  
  381. =head1 BUGS
  382.  
  383. (Ver 0.04) This module is much faster than it ought to be... Silly that I wondered
  384. wether I should implement it in perl or C, since perl is soo fast.
  385.  
  386. =head1 AUTHOR
  387.  
  388. Marc Lehmann <pcg@goof.com>
  389.  
  390. =head1 SEE ALSO
  391.  
  392. perl(1), L<Gimp>.
  393.  
  394. =cut
  395.